home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue47 / Clinic / NameHlp2U.pas next >
Encoding:
Pascal/Delphi Source File  |  1999-06-01  |  8.8 KB  |  278 lines
  1. unit NameHlp2U;
  2.  
  3. {$ifdef Ver90} //Delphi 2
  4.   {$define Delphi2}
  5. {$endif}
  6. {$ifdef Ver93} //BCB1
  7.   {$define Delphi2}
  8. {$endif}
  9.  
  10. interface
  11.  
  12. uses
  13. {$ifdef Delphi2} //BCB1
  14.   OLE2, 
  15. {$endif}
  16.   ShlObj, Windows, Classes, ComCtrls;
  17.  
  18. {$ifdef Delphi2}
  19. type
  20.   IShellFolder = class(IUnknown)
  21.     function ParseDisplayName(hwndOwner: HWND;
  22.       pbcReserved: Pointer; lpszDisplayName: POLESTR; var pchEaten: ULONG;
  23.       var ppidl: PItemIDList; var dwAttributes: ULONG): HResult; virtual; stdcall; abstract;
  24.     function EnumObjects(hwndOwner: HWND; grfFlags: DWORD;
  25.       var EnumIDList: IEnumIDList): HResult; virtual; stdcall; abstract;
  26.     function BindToObject(pidl: PItemIDList; pbcReserved: Pointer;
  27.       const riid: TIID; var ppvOut: Pointer): HResult; virtual; stdcall; abstract;
  28.     function BindToStorage(pidl: PItemIDList; pbcReserved: Pointer;
  29.       riid: TIID; var ppvObj: Pointer): HResult; virtual; stdcall; abstract;
  30.     function CompareIDs(lParam: LPARAM;
  31.       pidl1, pidl2: PItemIDList): HResult; virtual; stdcall; abstract;
  32.     function CreateViewObject(hwndOwner: HWND; {}const{}riid: TIID;
  33.       var ppvOut: Pointer): HResult; virtual; stdcall; abstract;
  34.     function GetAttributesOf(cidl: UINT; var apidl: PItemIDList;
  35.       var rgfInOut: UINT): HResult; virtual; stdcall; abstract;
  36.     function GetUIObjectOf(hwndOwner: HWND; cidl: UINT; var apidl: PItemIDList;
  37.       riid: TIID; var  prgfInOut: UINT; var ppvOut: Pointer): HResult; virtual; stdcall; abstract;
  38.     function GetDisplayNameOf(pidl: PItemIDList; uFlags: DWORD;
  39.       var lpName: TStrRet): HResult; virtual; stdcall; abstract;
  40.     function SetNameOf(hwndOwner: HWND; pidl: PItemIDList; lpszName: POLEStr;
  41.       uFlags: DWORD; var ppidlOut: PItemIDList): HResult; virtual; stdcall; abstract;
  42.   end;
  43. {$endif}
  44.  
  45. function CreateFolderObject(const ClsID: TGuid): IShellFolder;
  46. procedure GetFolderItems(Folder: IShellFolder; Items: TListItems);
  47. function GetSpecialFolderClsID(const FolderName: String): TGuid;
  48. function GetSpecialFolderLocation(Folder: Cardinal): String;
  49.  
  50. implementation
  51.  
  52. uses
  53. {$ifdef Delphi2}
  54.   OleAuto,
  55. {$else}
  56.   ComObj, ActiveX,
  57. {$endif}
  58.   Forms, SysUtils, Registry, IniFiles, Controls;
  59.  
  60. var
  61.   Malloc: IMalloc;
  62.  
  63. type
  64.   TShellDetails = record
  65.     fmt: Integer;
  66.     cxChar: Integer;
  67.     str: TStrRet;
  68.   end;
  69.  
  70. {$ifdef Delphi2}
  71. const
  72.   IID_IShellDetails: TGUID = (
  73.     D1:$000214EC;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
  74.  
  75. type
  76.   IShellDetails = class(IUnknown)
  77.     function GetDetailsOf(PIdl: PItemIDList; Col: UINT; var Details: TShellDetails): HResult; virtual; stdcall; abstract;
  78.     function ColumnClick(Col: Integer): HResult; virtual; stdcall; abstract;
  79.   end;
  80. {$else}
  81. const
  82.   IID_IShellDetails: TGUID = '{000214EC-0000-0000-C000-000000000046}';
  83.  
  84. type
  85.   IShellDetails = interface(IUnknown)
  86.     ['{000214EC-0000-0000-C000-000000000046}']
  87.     function GetDetailsOf(PIdl: PItemIDList; Col: UINT; var Details: TShellDetails): HResult; stdcall;
  88.     function ColumnClick(Col: Integer): HResult; stdcall;
  89.   end;
  90. {$endif}
  91.  
  92. function CreateFolderObject(const ClsID: TGuid): IShellFolder;
  93. begin
  94. {$ifdef Delphi2}
  95.   OleCheck(CoCreateInstance(ClsID, nil, CLSCTX_INPROC_SERVER or
  96.     CLSCTX_LOCAL_SERVER, IID_IShellFolder, Result));
  97. {$else}
  98.   Result := CreateCOMObject(ClsID) as IShellFolder
  99. {$endif}
  100. end;
  101.  
  102. function ControlTextWidth(AControl: TControl; const AString: String): Integer;
  103. begin
  104.   with TControlCanvas.Create do
  105.     try
  106.       Control := AControl;
  107.       Result := TextWidth(AString)
  108.     finally
  109.       Free
  110.     end;
  111. end;
  112.  
  113. function GetFolderItemsDetails(Folder: IShellFolder; Items: TListItems): Boolean;
  114. var
  115.   Enum: IEnumIDList;
  116.   PIDL: PItemIDList;
  117.   Fetched: {$ifdef Delphi2}ULong{$else}DWord{$endif};
  118.   ShellDetails: IShellDetails;
  119.   ColCount, Loop: Integer;
  120.   Details: TShellDetails;
  121.   DetailStr: String;
  122. begin
  123.   Result := True;
  124.   //Try and get IShellDetails directly from folder interface
  125.   if Failed(Folder.QueryInterface(IID_IShellDetails, ShellDetails)) then
  126.     //Try and get IShellDetails indirectly from folder interface
  127.     //Folder.CreateViewObject(Application.handle, IID_IShellDetails, Pointer(ShellDetails));
  128.     Folder.CreateViewObject(0, IID_IShellDetails, Pointer(ShellDetails));
  129.   //Exit if shell details interface unavailable
  130.   if ShellDetails = nil then
  131.   begin
  132.     Result := False;
  133.     Exit
  134.   end;
  135.   //Add in relevant column headers
  136.   ColCount := 0;
  137.   while Succeeded(ShellDetails.GetDetailsOf(nil, ColCount, Details)) do
  138.   begin
  139.     with TListView(Items.Owner).Columns.Add do
  140.     begin
  141.       Width := ControlTextWidth(Items.Owner, 'g') * Details.cxChar;
  142.       case Details.str.uType of
  143.         STRRET_WSTR:   Caption := WideCharToString(Details.str.pOleStr);
  144.         STRRET_OFFSET: Caption := '';
  145.         STRRET_CSTR:   Caption := Details.str.cStr;
  146.       end;
  147.     end;
  148.     Inc(ColCount);
  149.   end;
  150.   //Get enumeration object, just for files - not folders
  151.   OleCheck(Folder.EnumObjects(
  152.     Application.Handle, SHCONTF_NONFOLDERS, Enum));
  153.   //Get 1 item at a time. Not efficient, but still...
  154.   while (Enum.Next(1, PIDL, Fetched) = NOERROR) and (Fetched = 1) do
  155.   begin
  156.     for Loop := 0 to ColCount - 1 do
  157.     begin
  158.       //Ask for the column text
  159.       OleCheck(ShellDetails.GetDetailsOf(PIDL, Loop, Details));
  160.       //It may come back in a number of formats
  161.       case Details.str.uType of
  162.         STRRET_WSTR:
  163.         begin
  164.           DetailStr := WideCharToString(Details.str.pOleStr);
  165.           Malloc.Free(Details.str.pOleStr)
  166.         end;
  167.         STRRET_OFFSET:
  168.           DetailStr := PChar(Cardinal(PIDL) + Details.str.uOffset);
  169.         STRRET_CSTR:
  170.           DetailStr := Details.str.cStr;
  171.       end;
  172.       if Loop = 0 then //Add in either main item text
  173.         Items.Add.Caption := DetailStr
  174.       else //or a subitem (for report style lists)
  175.         Items[Items.Count - 1].SubItems.Add(DetailStr)
  176.     end;
  177.     Malloc.Free(PIDL); //Free item
  178.   end
  179. end;
  180.  
  181. procedure GetFolderItemsNoDetails(Folder: IShellFolder; Items: TListItems);
  182. var
  183.   Enum: IEnumIDList;
  184.   PIDL: PItemIDList;
  185.   Fetched: {$ifdef Delphi2}ULong{$else}DWord{$endif};
  186.   StrRet: TStrRet;
  187. begin
  188.   with TListView(Items.Owner).Columns.Add do
  189.   begin
  190.     Caption := 'Name';
  191.     Width := 400;
  192.   end;
  193.   //Get enumeration object, just for files - not folders
  194.   OleCheck(Folder.EnumObjects(
  195.     Application.Handle, SHCONTF_NONFOLDERS, Enum));
  196.   //Get 1 item at a time. Not efficient, but still...
  197.   while (Enum.Next(1, PIDL, Fetched) = NOERROR) and (Fetched = 1) do
  198.   begin
  199.     //Ask for the name
  200.     OleCheck(Folder.GetDisplayNameOf(PIDL, SHGDN_FORPARSING, StrRet));
  201.     //It may come back in a number of formats
  202.     case StrRet.uType of
  203.       STRRET_WSTR:
  204.       begin
  205.         Items.Add.Caption := WideCharToString(StrRet.pOleStr);
  206.         Malloc.Free(StrRet.pOleStr)
  207.       end;
  208.       STRRET_OFFSET:
  209.         Items.Add.Caption := PChar(Cardinal(PIDL) + StrRet.uOffset);
  210.       STRRET_CSTR:
  211.         Items.Add.Caption := StrRet.cStr;
  212.     end;
  213.     Malloc.Free(PIDL); //Free item
  214.   end
  215. end;
  216.  
  217. procedure GetFolderItems(Folder: IShellFolder; Items: TListItems);
  218. begin
  219.   TListView(Items.Owner).Columns.Clear;
  220.   Items.Clear;
  221.   Items.BeginUpdate;
  222.   try
  223.     if not GetFolderItemsDetails(Folder, Items) then
  224.       GetFolderItemsNoDetails(Folder, Items)
  225.   finally
  226.     Items.EndUpdate
  227.   end
  228. end;
  229.  
  230. function GetSpecialFolderClsID(const FolderName: String): TGuid;
  231. var
  232.   ClsID: String;
  233. {$ifdef Delphi2}
  234. const
  235.   REGSTR_PATH_EXPLORER        = 'Software\Microsoft\Windows\CurrentVersion\Explorer';
  236.   REGSTR_PATH_SPECIAL_FOLDERS = REGSTR_PATH_EXPLORER + '\Shell Folders';
  237. {$endif}
  238. begin
  239.   with TRegistry.Create do
  240.     try
  241.       //Locate special folders in registry
  242.       if OpenKey(REGSTR_PATH_SPECIAL_FOLDERS, False) then
  243.         //Read requested folder name & read DESKTOP.INI
  244.         with TIniFile.Create(ReadString(FolderName) + '\DESKTOP.INI') do
  245.           try
  246.             //Entry should be marked as CLSID or UICLSID
  247.             ClsID := ReadString('.ShellClassInfo', 'CLSID', '');
  248.             if ClsID = '' then
  249.               ClsID := ReadString('.ShellClassInfo', 'UICLSID', '');
  250.             //Translate from string to real GUID record
  251.             Result := {$ifdef Delphi2}StringToClassID(ClsID){$else}StringToGUID(ClsID){$endif}
  252.           finally
  253.             Free //delete TIniFile
  254.           end;
  255.     finally
  256.       Free //Delete TRegistry
  257.     end;
  258. end;
  259.  
  260. function GetSpecialFolderLocation(Folder: Cardinal): String;
  261. var
  262.   PIDList: PItemIDList;
  263.   Buf: array[0..MAX_PATH] of Char;
  264. begin
  265.   Result := 'Not available';
  266.   if (SHGetSpecialFolderLocation(
  267.         Application.Handle, Folder, PIDList) = NOERROR) and
  268.      SHGetPathFromIDList(PIDList, Buf) then
  269.   begin
  270.     Result := Buf;
  271.     Malloc.Free(PIDList);
  272.   end
  273. end;
  274.  
  275. initialization
  276.   ShGetMalloc(Malloc);
  277. end.
  278.